Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Applications/P4⁄Mac 2.0d4/Mac source 2.0/Console.p

Text File | 1996-09-28 | 10.4 KB | 473 lines | [TEXT/PJMM]

{A TTY-style console window for P4/Mac, by Ingemar Ragnemalm 1996}

{This unit implements basic text-based I/O in a window. It shows white text on a blue bottom, in order to}
{emphasize the feeling of "good old 70's", so nobody gets the false impression that this is supposed to}
{be a modern system.}

unit Console;

interface
    uses
        TransSkel;

    type
        CharPointer = ^Char;
    procedure ConsoleWrite (msg: Str255);
    procedure ConsoleWriteLn (msg: Str255);
    procedure ConsoleNewLine;
    function ConsoleReadLn: Str255;
    procedure ConsoleGotoXY (x, y: Integer);
    procedure ConsoleClearScreen;

    function ConsoleReadChar: Char;
    function ConsolePeekChar: Char;
    function ConsoleReadInt: Integer;
    function ConsoleReadReal: Real;
    function ConsoleReadEOL: Boolean;
    function ConsoleReadEOF: Boolean;
    function ConsoleInput: CharPointer;
    procedure ConsoleGet;
    procedure ConsoleResetRead;

    var
        aborted: Boolean;

implementation

    type
        Str80 = string[80];

    var
        buffer: array[0..23] of Str80;
        posX, posY: Integer;
        gConsoleWindow: WindowPtr;

        info: FontInfo;

    const
        kConsoleWindowId = 1000;

    const
        kLeftArrow = $1C;
        kRightArrow = $1D;
        kUpArrow = $1E;
        kDownArrow = $1F;

    procedure SetTextFont (fontName: Str255);
        var
            fontNum: Integer;
    begin
        GetFNum(fontName, fontNum);
        TextFont(fontNum);
    end; {SetTextFont}

    procedure Update (resized: Boolean);
        var
            i: Integer;
    begin
        SetPort(gConsoleWindow);
        EraseRect(gConsoleWindow^.portRect);
        for i := 0 to 23 do
            begin
                MoveTo(info.widMax, i * (info.ascent + info.descent + info.leading) + info.ascent);
                DrawString(buffer[i]);
            end;
    end; {Update}

    procedure ConsoleInit;
    begin
        if gConsoleWindow = nil then
            begin
                gConsoleWindow := GetNewWindow(kConsoleWindowId, nil, WindowPtr(-1));
                if gConsoleWindow = nil then
                    begin
                        SysBeep(1);        {Hellre FakeAlert!}
                        ExitToShell;
                    end;

                SetPort(gConsoleWindow);

                if info.ascent = 0 then
                    begin
                        TextSize(9);
                        SetTextFont('Monaco');
                        GetFontInfo(info);
                    end;

                ForeColor(whiteColor);
                BackColor(blueColor);

                ConsoleClearScreen;

                if SkelWindow(gConsoleWindow, nil, nil, @Update, nil, nil, nil, nil, true) then
                    ;

            end;

        ShowWindow(gConsoleWindow);
        SelectWindow(gConsoleWindow);
        SetPort(gConsoleWindow);
    end; {ConsoleInit}

    procedure ConsoleLinefeed;
    begin
        posY := (posY + 1) mod 24;
    end; {ConsoleLinefeed}

    procedure ConsoleUp;
    begin
        posY := (posY + 23) mod 24;
    end; {ConsoleUp}

    procedure ConsoleBackSpace;
    begin
        posX := (posX + 78) mod 80 + 1;
        if posX = 80 then
            ConsoleUp;
    end; {ConsoleBackSpace}

    procedure ConsoleRight;
    begin
        posX := posX mod 80 + 1;
        if posX = 1 then
            ConsoleLinefeed;
    end; {ConsoleRight}

    procedure ConsoleWrite (msg: Str255);
        var
            r: Rect;
            i, j: Integer;
    begin
        ConsoleInit;

        for i := 1 to Length(msg) do
            begin
                if Ord(msg[i]) >= 32 then
                    begin
                        SetPort(gConsoleWindow);

{Möjligen kunde man snabba upp detta genom att samla ihop ett antal tecken och skriva alla på en gång!}

                        buffer[posY][posX] := msg[i];
                        SetRect(r, posX * info.widMax, posY * (info.ascent + info.descent + info.leading), (posX + 1) * info.widMax, (posY + 1) * (info.ascent + info.descent + info.leading));
                        EraseRect(r);
                        MoveTo(posX * info.widMax, posY * (info.ascent + info.descent + info.leading) + info.ascent);
                        DrawChar(buffer[posY][posX]);

                        posX := posX + 1;
                        if posX > 80 then
                            ConsoleNewLine;

                    end
                else
                    case Ord(msg[i]) of
                        9:
                            SysBeep(1);
                        13:
                            ConsoleNewLine;
                        12:
                            ConsoleClearScreen;
                        8, kLeftArrow:
                            ConsoleBackSpace;
                        10, kDownArrow:
                            ConsoleLinefeed;
                        kUpArrow:
                            ConsoleUp;
                        kRightArrow:
                            ConsoleRight;
{27 = ESCAPE, bra för specialare?}
                        otherwise
                    end; {case}
            end;

    end; {ConsoleWrite}

    procedure ConsoleWriteLn (msg: Str255);
    begin
        ConsoleWrite(msg);
        ConsoleNewLine;
    end; {ConsoleWriteLn}

    procedure ConsoleNewLine;
        var
            j: Integer;
            r: Rect;
    begin
        ConsoleInit;
        SetPort(gConsoleWindow);

        posX := 1;
        posY := posY + 1;
        if posY > 23 then
            begin
                for j := 1 to 23 do
                    buffer[j - 1] := buffer[j];
                buffer[23] := '                                                                                ';

                posY := 23;
                ScrollRect(gConsoleWindow^.portRect, 0, -info.ascent - info.descent - info.leading, nil);
                r := gConsoleWindow^.portRect;
                r.top := r.bottom - info.ascent - info.descent - info.leading;
                EraseRect(r);
            end;
    end; {ConsoleNewLine}

{Hur skall read/readln från console funka egentligen?}
    function ConsoleReadLn: Str255;
        var
            startReadX, startReadY, endRead: Integer;
            done: Boolean;
            theKey: Char;
            theEvent: EventRecord;
            r: Rect;

            flashed: Boolean;
            lastFlash: Longint;
        const
            kFlashTime = 15;

        procedure FlashCursor;
        begin
            flashed := not flashed;

            SetRect(r, posX * info.widMax, posY * (info.ascent + info.descent + info.leading), (posX + 1) * info.widMax, (posY + 1) * (info.ascent + info.descent + info.leading));
            InvertRect(r);
            lastFlash := TickCount;
        end;
        procedure SynchCursor;
        begin
            if flashed then
                FlashCursor;
        end;

    begin
        ConsoleInit;

{Blinkvariabler:}
        flashed := false;
        lastFlash := TickCount;

        startReadX := posX;
        startReadY := posY;
        endRead := startReadX;        {För att ha ett giltigt värde.}
        done := false;

{Två sätt att göra detta:}
{• TextEdit. Ger visst stöd för att fixa copy/paste och sånt.}
{• Eget.}

        repeat
            if GetNextEvent(keyDownMask + autoKeyMask + updateMask, theEvent) then
                case theEvent.what of
                    keyDown, autoKey:
                        begin
                            theKey := Char(BitAnd(theEvent.message, charCodeMask));
                            if Ord(theKey) = 13 then {Should handle Enter too!}
                                begin
                                    SynchCursor;

                                    done := true;
                                    endRead := posX;
                                    ConsoleNewLine;
                                end
                            else if (Ord(theKey) = 8) or (Ord(theKey) = $7F) then
                                begin
                                    if posX > startReadX then
                                        begin
                                            SynchCursor;

                                            ConsoleBackSpace;
                                            ConsoleWrite(' ');
                                            ConsoleBackSpace;
                                        end
                                end
                            else if (BitAnd(theEvent.modifiers, cmdKey) <> 0) and (theKey = '.') then {or (theKey = Char(27))}
                                aborted := true
                            else if Ord(theKey) >= 32 then
                                begin
                                    SynchCursor;
                                    if posX < 80 then
                                        ConsoleWrite(theKey)
                                    else
                                        SysBeep(1);
                                end;
                        end; {keyDown}
                    updateEvt:
                        begin
                            if WindowPtr(theEvent.message) = gConsoleWindow then
                                begin
                                    SetPort(gConsoleWindow);
                                    SynchCursor;
                                    BeginUpdate(gConsoleWindow);
                                    Update(false);
                                    EndUpdate(gConsoleWindow);
                                end;
                        end; {update}
                end; {case}

            if lastFlash + kFlashTime < TickCount then
                FlashCursor;

        until done or aborted;

        SynchCursor;

        ConsoleReadLn := ConCat(Copy(buffer[startReadY], startReadX, endRead - startReadX), Char(13));

    end; {ConsoleReadLn}

    var
        readBuffer: Str255;

    function ConsoleReadChar: Char;
    begin
        if readBuffer = '' then
            readBuffer := ConsoleReadLn;

{ConsoleReadChar := readBuffer[1];}
        if readBuffer <> '' then
            ConsoleReadChar := readBuffer[1]
        else
            ConsoleReadChar := Char(13);

        readBuffer := Copy(readBuffer, 2, Length(readBuffer) - 1);
    end; {ConsoleReadChar}

    function ConsolePeekChar: Char;
    begin
{if readBuffer = '' then}
{readBuffer := ConsoleReadLn;}

        if readBuffer <> '' then
            ConsolePeekChar := readBuffer[1]
        else
            ConsolePeekChar := Char(13);
    end; {ConsolePeekChar}

    function ConsoleReadInt: Integer;
        var
            theInt: Integer;
            first, negative: Boolean;
    begin
        theInt := 0;
        first := true;
        negative := false;

        if readBuffer = StringOf(Char(13)) then
            readBuffer := '';
        if readBuffer = '' then
            readBuffer := ConsoleReadLn;

        while (readBuffer <> '') do
            begin
                if readBuffer = '' then
                    Leave;
                if first and (readBuffer[1] = '-') then
                    begin
                        first := false;
                        negative := true;
                        readBuffer := Copy(readBuffer, 2, Length(readBuffer) - 1);
                    end;
                if ((Ord(readBuffer[1]) >= Ord('0')) and (Ord(readBuffer[1]) <= Ord('9'))) then
                    begin
                        theInt := theInt * 10 + Ord(readBuffer[1]) - Ord('0');
                        first := false;
                        readBuffer := Copy(readBuffer, 2, Length(readBuffer) - 1);
                    end
                else
                    Leave;
            end;

        if negative then
            theInt := -theInt;

        ConsoleReadInt := theInt;
        if readBuffer = StringOf(Char(13)) then
            readBuffer := '';
    end; {ConsoleReadInt}

    function ConsoleReadReal: Real;
        var
            theReal: Real;
            i: Integer;
    begin
        theReal := 0.0;

        if readBuffer = StringOf(Char(13)) then
            readBuffer := '';
        if readBuffer = '' then
            readBuffer := ConsoleReadLn;

{Skippa inledande mellanslag}
        for i := 1 to Length(readBuffer) do
            if readBuffer[i] <> ' ' then
                Leave;
{Tag alla tecken som är tillåtna i real}
        for i := i to Length(readBuffer) do
            if (Ord(readBuffer[1]) < Ord('0')) and (Ord(readBuffer[1]) > Ord('9')) and (readBuffer[i] <> '.') and (readBuffer[i] <> '-') and (readBuffer[i] <> 'E') then
                Leave;

        ReadString(Copy(readBuffer, 1, i - 1), theReal);
        readBuffer := Copy(readBuffer, i, Length(readBuffer) - i + 1);
        ConsoleReadReal := theReal;

        if readBuffer = StringOf(Char(13)) then
            readBuffer := '';

    end; {ConsoleReadReal}

{Try to mimick input^}
    function ConsoleInput: CharPointer;
    begin
        ConsoleInput := @readBuffer[1];
    end; {ConsoleInput}

{Try to mimick getfile(input)}
    procedure ConsoleGet;
    begin
        if readBuffer = '' then
            readBuffer := ConsoleReadLn
        else
            readBuffer := Copy(readBuffer, 2, Length(readBuffer) - 1);
    end; {ConsoleGet}

    function ConsoleReadEOL: Boolean;
    begin
        ConsoleReadEOL := (readBuffer = '') or (readBuffer = StringOf(Char(13)));
    end; {ConsoleReadEOL}

    function ConsoleReadEOF: Boolean;
    begin
        ConsoleReadEOF := false;
    end; {ConsoleReadEOF}

    procedure ConsoleResetRead;
    begin
        readBuffer := '';
    end; {ConsoleResetRead}


{Hur kommer vi åt denna från P4?}
    procedure ConsoleGotoXY (x, y: Integer);
    begin
        posX := x;
        posY := y;
    end; {ConsoleGotoXY}

{Denna kan vi gott styra med kontroll-koder. CHR$(12) är Form Feed.}
    procedure ConsoleClearScreen;
        var
            i: Integer;
    begin
        ConsoleInit;

        for i := 0 to 23 do
            buffer[i] := '                                                                                ';
        posX := 1;
        posY := 0;

        SetPort(gConsoleWindow);
        EraseRect(gConsoleWindow^.portRect);
    end; {ConsoleClearScreen}

end.